(* ::Package:: *)

(************************************************************************)\012(* This file was generated automatically by the Mathematica front end.  *)\012(* It contains Initialization cells from a Notebook file, which         *)\012(* typically will have the same name as this file except ending in      *)\012(* ".nb" instead of ".m".                                               *)\012(*                                                                      *)\012(* This file is intended to be loaded into the Mathematica kernel using *)\012(* the package loading commands Get or Needs.  Doing so is equivalent   *)\012(* to using the Evaluate Initialization Cells menu command in the front *)\012(* end.                                                                 *)\012(*                                                                      *)\012(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)\012(* automatically each time the parent Notebook file is saved in the     *)\012(* Mathematica front end.  Any changes you make to this file will be    *)\012(* overwritten.                                                         *)\012(************************************************************************)\012\012

(* ::Input::Initialization:: *)
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\BabyDoPeGDO"];
Once[<<KnotTheory`];
Once[Get@"../Profile/Profile.m"];


$k=1;


(* ::Input::Initialization:: *)
CCF[\[ScriptCapitalE]_] := ExpandDenominator@ExpandNumerator@Together[\[ScriptCapitalE]];
CF[\[ScriptCapitalE]_List]:=CF/@\[ScriptCapitalE];
CF[\[ScriptCapitalE]_\[Epsilon]Series]:=CF/@\[ScriptCapitalE];
CF[\[ScriptCapitalE]_] := Subscript[PP, CF]@Module[
{vs=Cases[\[ScriptCapitalE],Subscript[(y|x|\[Eta]|\[Xi]), _],\[Infinity]]\[Union]{y|x|\[Eta]|\[Xi]}},
Total[CoefficientRules[Expand[\[ScriptCapitalE]], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))]
];
(*CF[\[ScriptCapitalE]_] := Subscript[PP, CF]@CCF[\[ScriptCapitalE]];*)
CF[\[ScriptCapitalE]_\[DoubleStruckCapitalE]]:=CF/@\[ScriptCapitalE]; 
CF[Subscript[\[DoubleStruckCapitalE], sp___][\[ScriptCapitalE]s___]]:=CF/@Subscript[\[DoubleStruckCapitalE], sp][\[ScriptCapitalE]s];


(* ::Input::Initialization:: *)
\[Epsilon]Series/: S1_\[Epsilon]Series\[Congruent]S2_\[Epsilon]Series:=Length[S1]==Length[S2]\[And]Inner[CF[#1]==CF[#2]&,S1,S2,And];
\[Epsilon]Series[0]:=\[Epsilon]Series@@Table[0,$k+1];
\[Epsilon]Series/: S1_\[Epsilon]Series+S2_\[Epsilon]Series := \[Epsilon]Series@@Table[S1[[k]]+S2[[k]],{k,Min[Length@S1,Length@S2]}];
\[Epsilon]Series/: S1_\[Epsilon]Series*S2_\[Epsilon]Series := \[Epsilon]Series@@Table[Sum[S1[[j+1]]*S2[[k-j+1]], {j,0,k}],{k,0,Min[Length@S1,Length@S2]-1}];
\[Epsilon]Series /:c_*S_\[Epsilon]Series:=(c #)& /@ S;
\[Epsilon]Series/:\!\(
\*SubscriptBox[\(\[PartialD]\), \(vs___\)]S_\[Epsilon]Series\):=(s|->\!\(
\*SubscriptBox[\(\[PartialD]\), \(vs\)]s\))/@S;


(* ::Input::Initialization:: *)
SetAttributes[Define, HoldAll];
Define[def_,defs__] := (Define[def]; Define[defs];);
Define[Subscript[op_, is__]=\[ScriptCapitalE]_] := Module[{SD,ii,jj,kk,isp,nis,nisp,sis},Block[{i,j,k},
ReleaseHold[Hold[
SD[Subscript[op, nisp,$k_Integer],Block[{i,j,k},Subscript[op, isp,$k]=\[ScriptCapitalE];Subscript[op, nis,$k]]];
SD[Subscript[op, isp],\!\(\*SubscriptBox[\(op\), \({is}, $k\)]\)]; SD[Subscript[op, sis__],\!\(\*SubscriptBox[\(op\), \({sis}\)]\)];
]/. {SD->SetDelayed,
isp->{is}/.{i->i_,j->j_,k->k_},
nis->{is}/.{i->ii,j->jj,k->kk},
nisp->{is}/.{i->ii_,j->jj_,k->kk_}
}]  ]]


(* ::Input::Initialization:: *)
Define[Subscript[m, i,j->k]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({i, j} \[Rule] {k}\)]\)[1,-Subscript[\[Xi], i] Subscript[\[Eta], j]+(Subscript[\[Eta], i]+Subscript[\[Eta], j])Subscript[y, k]+(Subscript[\[Xi], i]+Subscript[\[Xi], j])Subscript[x, k],\[Epsilon]Series[0]]]


(* ::Input::Initialization:: *)
AllMonomials[{},0]={1};
AllMonomials[{},d_Integer] /; d>0 := {};
AllMonomials[{v_,vs___},d_Integer] := Join@@Table[v^(d-k) AllMonomials[{vs},k],{k,0,d}];
AllMonomials[vs_List, {d_}] := Join@@Table[AllMonomials[vs,k],{k,0,d}];


(* ::Input::Initialization:: *)
Basis[js_List,m_]:=Flatten@Outer[Times,AllMonomials[Table[Subscript[y, j],{j,js}],m],AllMonomials[Table[Subscript[x, j],{j,js}],m]];
Basis[js_List,{m_}]:=Flatten@Table[Basis[js,k],{k,0,m}]


(* ::Input::Initialization:: *)
GenericCombination[bas_,c_]:=bas . Table[Subscript[c, j],{j,Length@bas}];
GenericCombination[bas_,Subscript[c_, k_]]:=bas . Table[Subscript[c, k,j],{j,Length@bas}];


(* ::Input::Initialization:: *)
Subscript[R, i_,j_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i, j}\)]\)[1,(-1+T) Subscript[x, j] (Subscript[y, i]-Subscript[y, j]),\[Epsilon]Series@@Prepend[0]@Table[GenericCombination[Basis[{i,j},{k+1}],Subscript[c, k]],{k,$k}]];
Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), i_,j_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i, j}\)]\)[1,(-1+1/T) Subscript[x, j] (Subscript[y, i]-Subscript[y, j]),\[Epsilon]Series@@Prepend[0]@Table[GenericCombination[Basis[{i,j},{k+1}],Subscript[d, k]],{k,$k}]];
Subscript[CC, i_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i}\)]\)[Sqrt[T],0,\[Epsilon]Series@@Prepend[0]@Table[GenericCombination[Basis[{i},{k+1}],Subscript[e, k]],{k,$k}]];
Subscript[\!\(\*OverscriptBox[\(CC\), \(_\)]\), i_]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i}\)]\)[1/Sqrt[T],0,\[Epsilon]Series@@Prepend[0]@Table[GenericCombination[Basis[{i},{k+1}],Subscript[f, k]],{k,$k}]];


(* ::Input::Initialization:: *)
{SuperStar[y],SuperStar[x],SuperStar[\[Eta]],SuperStar[\[Xi]]}={\[Eta],\[Xi],y,x}; 
SuperStar[(vs_List)]:=(v|->SuperStar[v])/@vs;
SuperStar[(Subscript[u_, i_])]:=Subscript[(SuperStar[u]), i];


(* ::Input::Initialization:: *)
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][\[Omega]1_,Q1_,P1_]\[Congruent]\[DoubleStruckCapitalE][\[Omega]2_,Q2_,P2_]:=CF[\[Omega]1==\[Omega]2]\[And]CF[Q1==Q2]\[And](P1\[Congruent]P2);
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][\[Omega]1_,Q1_,P1_]\[DoubleStruckCapitalE][\[Omega]2_,Q2_,P2_]:=\[DoubleStruckCapitalE][\[Omega]1 \[Omega]2,Q1+Q2,P1+P2];
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]\[Congruent]Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] ^:= (d1==d2)\[And](r1==r2)\[And](\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]\[Congruent]\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]);
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] ^:= Subscript[\[DoubleStruckCapitalE], (d1\[Union]d2)->(r1\[Union]r2)]@@(\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]);
Subscript[Subscript[\[DoubleStruckCapitalE], dr_][\[ScriptCapitalE]s___], $k_]:=Subscript[\[DoubleStruckCapitalE], dr]@@Subscript[\[DoubleStruckCapitalE][\[ScriptCapitalE]s], $k];


(* ::Input::Initialization:: *)
Subscript[\[DoubleStruckCapitalE], d1_->r1_][\[ScriptCapitalE]1s___]//Subscript[\[DoubleStruckCapitalE], d2_->r2_][\[ScriptCapitalE]2s___] :=Module[{is=r1\[Intersection]d2,lvs},
lvs=Flatten@Table[{Subscript[x, $@i],Subscript[y, $@i]},{i,is}];
Subscript[\[DoubleStruckCapitalE], (d1\[Union]Complement[d2,is])->(r2\[Union]Complement[r1,is])]@@(Subscript[Zip, lvs\[Union]SuperStar[lvs]][SuperStar[lvs] . lvs,Times[
\[DoubleStruckCapitalE][\[ScriptCapitalE]1s]/.Table[Subscript[(v:x|y), i]->Subscript[v, $@i],{i,is}],
\[DoubleStruckCapitalE][\[ScriptCapitalE]2s]/.Table[Subscript[(v:\[Xi]|\[Eta]), i]->Subscript[v, $@i],{i,is}]
]])
]


(* ::Input::Initialization:: *)
Subscript[Zip, vs_][\[ScriptCapitalF]_,\[ScriptCapitalE]_]:=\[LeftAngleBracket]\[ScriptCapitalF],\[ScriptCapitalE]\[RightAngleBracket]//Subscript[Zip1, vs]//Subscript[Zip2, vs]//Subscript[Zip3, vs]


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Zip1\), \({}\)]\)=Identity;
Subscript[Zip1, vs_]@\[LeftAngleBracket]\[ScriptCapitalF]_,\[DoubleStruckCapitalE][\[Omega]_,Q_,P_]\[RightAngleBracket] := Subscript[PP, Zip1]@Module[{\[ScriptCapitalI],F,G,u,v},
\[ScriptCapitalI]=IdentityMatrix@Length@vs;
F=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\[ScriptCapitalF]\),{u,SuperStar[vs]},{v,SuperStar[vs]}];
G=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]Q\),{u,vs},{v,vs}];
CF/@\[LeftAngleBracket]SuperStar[vs] . F . Inverse[\[ScriptCapitalI]-G . F] . SuperStar[vs]/2, \[DoubleStruckCapitalE][PowerExpand@Factor[\[Omega]  Det[\[ScriptCapitalI]- G . F]^(-1/2)],Q-vs . G . vs/2,P]\[RightAngleBracket]
]


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Zip2\), \({}\)]\)=Identity;
Subscript[Zip2, vs_]@\[LeftAngleBracket]\[ScriptCapitalF]_,\[DoubleStruckCapitalE][\[Omega]_,Q_,P_]\[RightAngleBracket] := Subscript[PP, Zip2]@Module[{F,Y,u,v},
F=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\[ScriptCapitalF]\),{u,SuperStar[vs]},{v,SuperStar[vs]}];
Y=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]Q\),{v,vs}];
CF/@\[LeftAngleBracket]\[ScriptCapitalF], \[DoubleStruckCapitalE][\[Omega],Q-Y . vs+Y . F . Y/2, P/.Thread[vs->vs+F . Y]]\[RightAngleBracket]
]


(* ::Input::Initialization:: *)
Subscript[Zip3, vs_]@\[LeftAngleBracket]\[ScriptCapitalF]_,\[DoubleStruckCapitalE][\[Omega]_,Q_,P_]\[RightAngleBracket] := Subscript[PP, Zip3]@Module[{Z,u,v,m,j},
Z[0]=P;
For[m=0,m<2$k,++m,
Z[m+1]=CF[1/(2(m+1)) Sum[\!\(
\*SubscriptBox[\(\[PartialD]\), \(
\*SuperscriptBox[\(u\), \(*\)], 
\*SuperscriptBox[\(v\), \(*\)]\)]\[ScriptCapitalF]\)(\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]\(Z[m]\)\)+Sum[(\!\(
\*SubscriptBox[\(\[PartialD]\), \(u\)]\(Z[j]\)\))(\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]\(Z[m - j]\)\)),{j,0,m}]),{u,vs},{v,vs}]]
];
\[DoubleStruckCapitalE][\[Omega],Q,CF[Sum[Z[m],{m,0,2$k}]/.Table[v->0,{v,vs}]]]
]


(* ::Input::Initialization:: *)
Define[Subscript[Kink, i]=Subscript[CC, 3] Subscript[R, 1,2]//Subscript[m, 2,3->2]//Subscript[m, 2,1->i], Subscript[\!\(\*OverscriptBox[\(Kink\), \(_\)]\), i]=Subscript[CC, 3] Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), 1,2]//Subscript[m, 1,3->1]//Subscript[m, 1,2->i]]


(* ::Input::Initialization:: *)
RVK[pd_PD]:=Module[{n,xs,x,rots,front={0},k},
n=Length@pd;rots=Table[0,{2n}];
xs=Cases[pd,x_X:>\[Piecewise]{
 {Xp[x[[4]],x[[1]]], PositiveQ@x},
 {Xm[x[[2]],x[[1]]], True}
}];
For[k=0,k<2n,++k,If[k==0\[Or]FreeQ[front,-k],
front=Flatten[front/.k->(xs/.{
Xp[k+1,l_]|Xm[l_,k+1]:>{l,k+1,1-l},
Xp[l_,k+1]|Xm[k+1,l_]:>(++rots[[l]];{1-l,k+1,l})
})],
Cases[front,k|-k]/.{k,-k}:>--rots[[k+1]];
]];
RVK[xs,rots] ];
RVK[K_]:=RVK[PD[K]];


(* ::Input::Initialization:: *)
rot[i_,0]:=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {i}\)]\)[1,0,\[Epsilon]Series@0];
rot[i_,n_]:=Module[{j},
rot[i,n]=If[n>0,rot[i,n-1]Subscript[CC, j],rot[i,n+1]Subscript[\!\(\*OverscriptBox[\(CC\), \(_\)]\), j]]//Subscript[m, i,j->i]];


(* ::Input::Initialization:: *)
Z[K_] := Z[RVK@K];
Z[rvk_RVK] := (*Z[rvk] =*)Module[{todo,n,rots,\[Zeta],done,st,cx, \[Zeta]1, i,j,k,k1,k2,k3},
{todo,rots}=List@@rvk;
AppendTo[rots,0];
n=Length[todo];
\[Zeta]=\!\(\*SubscriptBox[\(\[DoubleStruckCapitalE]\), \({} \[Rule] {0}\)]\)[1,0,\[Epsilon]Series@0];
done={0};
st=Range[0,2n+1];
While[{}=!=($M=todo),
{cx}=MaximalBy[todo, Length[done\[Intersection]{#[[1]], #[[2]], #[[1]]-1,#[[2]]-1}]&,1];
{i,j}=List@@cx;
\[Zeta]1=Switch[Head[cx],
 Xp, (Subscript[R, i,j] Subscript[\!\(\*OverscriptBox[\(Kink\), \(_\)]\), k])//Subscript[m, j,k->j],
 Xm, (Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), i,j] Subscript[Kink, k])//Subscript[m, j,k->j]
];
\[Zeta]1=(rot[k,rots[[i]]]\[Zeta]1)//Subscript[m, k,i->i]; rots[[i]]=0;
\[Zeta]1=(\[Zeta]1 rot[k, rots[[i+1]]])//Subscript[m, i,k->i]; rots[[i+1]]=0;
\[Zeta]1=(rot[k,rots[[j]]]\[Zeta]1)//Subscript[m, k,j->j]; rots[[j]]=0;
\[Zeta]1=(\[Zeta]1 rot[k, rots[[j+1]]])//Subscript[m, j,k->j]; rots[[j+1]]=0;
\[Zeta]*=\[Zeta]1;
If[MemberQ[done, i], \[Zeta]=\[Zeta]//Subscript[m, i,i+1->i]; st=st/.st[[i+2]]->st[[i+1]]];
If[MemberQ[done, i-1],  \[Zeta]=\[Zeta]//Subscript[m, st[[i]],i->st[[i]]]; st=st/.st[[i+1]]->st[[i]]]; 
If[MemberQ[done, j],  \[Zeta]=\[Zeta]//Subscript[m, j,j+1->j]; st=st/.st[[j+2]]->st[[j+1]]]; 
If[MemberQ[done, j-1],  \[Zeta]=\[Zeta]//Subscript[m, st[[j]],j->st[[j]]]; st=st/.st[[j+1]]->st[[j]]];
done=done\[Union]{i-1,i,j-1,j};
todo=DeleteCases[todo, cx]
];
CF/@ (\[Zeta] (*/. {Subscript[x, 0]\[Rule]x,Subscript[y, 0]\[Rule]y,Subscript[a, 0]\[Rule]a}*))
]



